home *** CD-ROM | disk | FTP | other *** search
/ Celestin Apprentice 4 / Apprentice-Release4.iso / Languages / XLISP 3.0a1 / CREC.LSP < prev    next >
Encoding:
Text File  |  1995-03-11  |  4.2 KB  |  87 lines  |  [TEXT/????]
  1. (define-macro (define-crecord record-name fields)
  2.   (let* ((record-name-string (symbol->string record-name))
  3.          (constructor-name (intern (string-append "MAKE-" record-name-string)))
  4.          (indexer-name (intern (string-append record-name-string "-ADDRESS")))
  5.          (size-name (intern (string-append record-name-string "-SIZE")))
  6.          (field-macros '())
  7.          (field-offset 0)
  8.          (make-field-macros 
  9.            (named-lambda make-field-macros (field-def)
  10.              (let* ((field-name (first field-def))
  11.                     (field-name-string (symbol->string field-name))
  12.                     (field-type-name (second field-def))
  13.                     (field-type (crecord-type field-type-name))
  14.                     (field-is-array? (not (null? (cddr field-def))))
  15.                     (field-count (if field-is-array? (third field-def) 1))
  16.                     (field-size (get-crecord-type-size field-type))
  17.                     (getter-name (intern (string-append record-name-string "-" field-name-string)))
  18.                     (get-addr-name (intern (string-append record-name-string "-" field-name-string "-ADDRESS")))
  19.                     (setter-name (intern (string-append "SET-" record-name-string "-" field-name-string "!")))
  20.                     (offset-name (intern (string-append record-name-string "-" field-name-string "-OFFSET"))))
  21.                (push! `(define-macro (,getter-name record &optional i)
  22.                          (if i
  23.                            `(get-crecord-field ,record ,(simplify-index ,field-offset ,field-size i) ,,field-type)
  24.                            `(get-crecord-field ,record ,,field-offset ,,field-type))) field-macros)
  25.                (push! `(define-macro (,get-addr-name record &optional i)
  26.                          (if i
  27.                            `(get-crecord-field-address ,record ,(simplify-index ,field-offset ,field-size i) 'pointer)
  28.                            `(get-crecord-field-address ,record ,,field-offset 'pointer))) field-macros)
  29.                (push! `(define-macro (,setter-name record value &optional i)
  30.                          (if i
  31.                            (let ((value i)    ; looks better to have index before value
  32.                                  (i value))
  33.                              `(set-crecord-field! ,record ,(simplify-index ,field-offset ,field-size i) ,,field-type ,value))
  34.                            `(set-crecord-field! ,record ,,field-offset ,,field-type ,value))) field-macros)
  35.                (push! `(define ,offset-name ,field-offset) field-macros)
  36.                (+ field-offset (* field-size field-count))))))
  37.     (let loop ((fields fields))
  38.       (when fields
  39.         (let ((field-def (car fields)))
  40.           (if (atom? (car field-def))
  41.             (set! field-offset (make-field-macros field-def))
  42.             (let ((new-offset field-offset))
  43.               (let field-loop ((fields field-def))
  44.                 (when fields
  45.                   (let* ((field-def (car fields))
  46.                          (this-offset (make-field-macros field-def)))
  47.                     (when (> this-offset new-offset)
  48.                       (set! new-offset this-offset))
  49.                     (field-loop (cdr fields)))))
  50.               (set! field-offset new-offset)))
  51.           (loop (cdr fields)))))
  52.     (push! `',record-name field-macros)
  53.     `(begin
  54.        (define-macro (,constructor-name &optional size)
  55.          (if size
  56.            `(allocate-cmemory ',',record-name (* ,,field-offset ,size))
  57.            `(allocate-cmemory ',',record-name ,,field-offset)))
  58.        (define-macro (,indexer-name record i)
  59.          `(get-crecord-field-address ,record (* ,,field-offset ,i) 'pointer))
  60.        (define ,size-name ,field-offset)
  61.        ,@(reverse field-macros))))
  62.  
  63. (define (simplify-index base size i)
  64.   (let ((offset (if (number? i)
  65.                   (* size i)
  66.                   (if (= size 1)
  67.                     i
  68.                     `(* ,size ,i)))))
  69.     (if (= base 0)
  70.       offset
  71.       (if (number? offset)
  72.         (+ base offset)
  73.         `(+ ,base ,offset)))))
  74.  
  75. (define (crecord-type name)
  76.   (case name
  77.     (char 1)
  78.     (uchar 2)
  79.     (short 3)
  80.     (ushort 4)
  81.     (int 5)
  82.     (uint 6)
  83.     (long 7)
  84.     (ulong 8)
  85.     (ptr 9)
  86.     (else (error "unknown type ~S" name))))
  87.